home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
lsp
/
mislib.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-04
|
3KB
|
89 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; This file is IMPLEMENTATION-DEPENDENT.
(in-package 'lisp)
(export 'time)
(export '(decode-universal-time encode-universal-time))
(in-package 'system)
(proclaim '(optimize (safety 2) (space 3)))
(defmacro time (form)
`(let (real-start real-end run-start run-end x)
(setq real-start (get-internal-real-time))
(setq run-start (get-internal-run-time))
(setq x (multiple-value-list ,form))
(setq run-end (get-internal-run-time))
(setq real-end (get-internal-real-time))
(fresh-line *trace-output*)
(format *trace-output*
"real time : ~,3F secs~%~
run time : ~,3F secs~%"
(/ (- real-end real-start) internal-time-units-per-second)
(/ (- run-end run-start) internal-time-units-per-second))
(values-list x)))
(defconstant month-days-list '(31 28 31 30 31 30 31 31 30 31 30 31))
(defconstant seconds-per-day #.(* 24 3600))
(defun leap-year-p (y)
(and (zerop (mod y 4))
(or (not (zerop (mod y 100))) (zerop (mod y 400)))))
(defun number-of-days-from-1900 (y)
(let ((y1 (1- y)))
(+ (* (- y 1900) 365)
(floor y1 4) (- (floor y1 100)) (floor y1 400)
-460)))
(defun decode-universal-time (ut &optional (tz *default-time-zone*))
(let (sec min h d m y dow)
(decf ut (* tz 3600))
(multiple-value-setq (d ut) (floor ut seconds-per-day))
(setq dow (mod d 7))
(multiple-value-setq (h ut) (floor ut 3600))
(multiple-value-setq (min sec) (floor ut 60))
(setq y (+ 1900 (floor d 366))) ; Guess!
(do ((x))
((< (setq x (- d (number-of-days-from-1900 y)))
(if (leap-year-p y) 366 365))
(setq d (1+ x)))
(incf y))
(when (leap-year-p y)
(when (= d 60)
(return-from decode-universal-time
(values sec min h 29 2 y dow nil tz)))
(when (> d 60) (decf d)))
(do ((l month-days-list (cdr l)))
((<= d (car l)) (setq m (- 13 (length l))))
(decf d (car l)))
(values sec min h d m y dow nil tz)))
(defun encode-universal-time (sec min h d m y
&optional (tz *default-time-zone*))
(incf h tz)
(when (<= 0 y 99)
(multiple-value-bind (sec min h d m y1 dow dstp tz)
(get-decoded-time)
(declare (ignore sec min h d m dow dstp tz))
(incf y (- y1 (mod y1 100)))
(cond ((< (- y y1) -50) (incf y 100))
((>= (- y y1) 50) (decf y 100)))))
(unless (and (leap-year-p y) (> m 2)) (decf d 1))
(+ (* (apply #'+ d (number-of-days-from-1900 y)
(butlast month-days-list (- 13 m)))
seconds-per-day)
(* h 3600) (* min 60) sec))